home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / NIH Image 1.62b11 / Macros / More Macros < prev    next >
Text File  |  1996-04-29  |  10KB  |  431 lines
  1. procedure ShowTime(nPixels, startTicks: integer);
  2. var
  3.   time: real;
  4.   cr: string;
  5. begin
  6.   time := (TickCount - StartTicks) / 60;
  7.   cr := chr(13);
  8.   PutMessage(nPixels:1, ' pixels', cr, time:1:2, ' seconds',
  9.      cr, nPixels/time:1:0, ' pixels/second');
  10. end;
  11.  
  12. macro 'Fast Invert';
  13. var
  14.   width, height, StartTicks: integer;
  15. begin
  16.   GetPicSize(width,height);
  17.   StartTicks := TickCount;
  18.   Invert;
  19.   ShowTime(width*height, StartTicks);
  20. end;
  21.  
  22. macro 'Slow Invert';
  23. {
  24. This macro illustrates why it's not a good idea to use
  25. macros for pixel-by-pixel processing.
  26. }
  27. var
  28.   width,height,value,x,y,StartTicks: integer;
  29. begin
  30.   GetPicSize(width,height);
  31.   if width = 0 then begin
  32.      beep;
  33.      PutMessage('Image required.');
  34.      exit;
  35.   end;
  36.   StartTicks := TickCount;
  37.   for y:=0 to height-1 do begin
  38.     GetRow(0,y,width);
  39.     for x:=0 to width-1 do LineBuffer[x]:=255-LineBuffer[x];
  40.     PutRow(0,y,width);
  41.   end;
  42.   ShowTime(width*height, StartTicks);
  43. end;
  44.  
  45. macro 'Real Slow Invert';
  46. {
  47. This macro illustrates why it's better to use GetRow
  48. and PutRow instead of GetPixel and PutPixel.
  49. }
  50. var
  51.   width,height,value,x,y,StartTicks: integer;
  52. begin
  53.   GetPicSize(width,height);
  54.   if width = 0 then begin
  55.      beep;
  56.      PutMessage('Image required.');
  57.      exit;
  58.   end;
  59.   StartTicks := TickCount;
  60.   for y:=0 to height-1 do
  61.     for x:=0 to width-1 do PutPixel(x, y, 255-GetPixel(x,y));
  62.   ShowTime(width*height, StartTicks);
  63. end;
  64.  
  65. macro '(---'; begin end;
  66.  
  67. macro 'Show Status [S]';
  68. var
  69.   roiType: integer;
  70. begin
  71.   NewTextWindow('Status');
  72.   writeln('MaxMeasuements = ', Get('MaxMeasurements'):1);
  73.   writeln('UndoBufSize = ', Get('UndoBufSize')/1024:1,'K');
  74.   writeln('FreeMem = ', Get('FreeMem')/1024:1,'K');
  75.   writeln('MaxBlock = ', Get('MaxBlock')/1024:1,'K');
  76.   roiType := Get('RoiType');
  77.   write('RoiType: ');
  78.   if roiType = 0 then write('No ROI or no image')
  79.   else if roiType = 1 then write('rectangle')
  80.   else if roiType = 2 then write('ellipse')
  81.   else if roiType = 3 then write('polygon')
  82.   else if roiType = 4 then write('freehand')
  83.   else if roiType = 5 then write('traced')
  84.   else if roiType = 6 then write('straight line')
  85.   else if roiType = 7 then write('freehand line')
  86.   else if roiType = 8 then write('segmented line');
  87. end
  88.  
  89. macro 'Draw Vertical Calibration Bar';
  90. var
  91.   left,top,width,height,i,x,y2,inc:integer;
  92.   y:real;
  93. begin
  94.   GetRoi(left,top,width,height);
  95.   if width=0 then begin
  96.     beep;
  97.     PutMessage('Make a rectangular selection first.');
  98.     exit;
  99.   end;
  100.   SetFont('Helvetica');
  101.   SetFontSize(10);
  102.   SetText('Plain; Left; no background');
  103.   SetLineWidth(1);
  104.   Setforeground(255);
  105.   DrawScale;
  106.   x:=left;
  107.   y:=top;
  108.   inc:=height/10;
  109.   for i:=1 to 11 do begin
  110.     MoveTo(x+width+10,round(y)+2);
  111.     y2:=round(y);
  112.     if i=11 then y2:=y2-1;
  113.     write(cvalue(GetPixel(x,y2)):1:2);
  114.     y:=y+inc;
  115.   end;
  116. end;
  117.  
  118. macro 'ASCII Dump';
  119. {
  120. Generates an alphanumeric listing of pixels values starting at
  121. the upper left corner of the current selection. 20 rows and 44 columns
  122. can be displayed with the default 552 x 436 window.
  123. }
  124. var
  125.   image,dump,roiLeft,roiTop,roiWidth,roiHeight:integer;
  126.   h,v,value,MaxWidth,MaxHeight,width,height:integer;
  127. begin
  128.   image:=PicNumber;
  129.   GetRoi(RoiLeft,RoiTop,RoiWidth,RoiHeight);
  130.   if roiWidth=0 then begin
  131.     beep;
  132.     PutMessage('This macro requires a rectangular selection.');
  133.     exit;
  134.   end;
  135.   SetForegroundColor(255);
  136.   SetBackgroundColor(0);
  137.   MakeNewWindow('ASCII Dump');
  138.   dump:=PicNumber;
  139.   GetPicSize(width,height);
  140.   MaxWidth:=width div 24 - 2;
  141.   MaxHeight:=height div 9 - 3;
  142.   if roiWidth>MaxWidth then roiWidth:=MaxWidth;
  143.   if roiHeight>MaxHeight then roiHeight:=MaxHeight;
  144.   SetFont('Monaco');
  145.   SetFontSize(9);
  146.   SetText('With background; Left Justified');
  147.   MoveTo(2,12);
  148.   write('    ');
  149.   for h:=roiLeft to roiLeft+roiWidth-1 do write(h:4);
  150.   writeln;
  151.   writeln;
  152.   for v:=roiTop to roiTop+roiHeight-1 do begin
  153.     write(v:3,' ');
  154.     for h:=roiLeft to roiLeft+roiWidth-1 do begin
  155.       ChoosePic(image);
  156.       value:=GetPixel(h,v);
  157.       ChoosePic(dump);
  158.       write(value:4);
  159.     end;
  160.     writeln;
  161.   end;
  162.   ChoosePic(image);
  163. end;
  164.  
  165.  
  166. function hexDigit(digit: integer): string;
  167. begin
  168.          if digit <= 9 then
  169.                      hexDigit := chr(digit + ord('0'))
  170.             else
  171.                      hexDigit := chr(digit - 10 + ord('A'));
  172. end;
  173.  
  174.  
  175. function hex(value: integer): string;
  176. begin
  177.     hex := concat(hexDigit(value div 16), hexDigit(value mod 16));
  178. end;
  179.  
  180.  
  181. function GetByte(loc: integer): integer;
  182. begin
  183.     GetByte := GetPixel(loc mod width, loc div width);
  184. end;
  185.  
  186.  
  187. macro 'Hex Dump';
  188. {
  189. Generates a hex listing of pixels values starting at
  190. the first byte of the image. It can be useful
  191. for decoding image file headers.
  192. }
  193. var
  194.   width, height, nLines, line: integer;
  195.   i, j, BytesPerLine, loc, value: integer;
  196.   image, ascii, char: string;
  197. begin
  198.   SaveState;
  199.   nLines := 52;
  200.   BytesPerLine := 10;
  201.   image:=WindowTitle;
  202.   GetPicSize(width, height);
  203.   if width = 0 then begin
  204.      beep;
  205.      PutMessage('Image required.');
  206.      exit;
  207.   end;
  208.   SetFont('Monaco');
  209.   SetFontSize(9);
  210.   NewTextWindow('Hex Dump');
  211.   loc := 0;
  212.   for line := 0 to nLines - 1 do begin
  213.        write(loc:4, '  ');
  214.        ascii := '  ';
  215.        for i := 0 to BytesPerLine - 1 do begin
  216.            value := GetByte(loc);
  217.            write(hex(value), ' ');
  218.            if (value >= 32) and (value <= 127) then
  219.                char := chr(value)
  220.            else
  221.                char := '-';
  222.            ascii := concat(ascii, char);
  223.            loc := loc + 1;
  224.        end;
  225.        writeln(ascii);
  226.   end;
  227.   RestoreState;
  228. end;
  229.  
  230.  
  231. macro 'Scale and Rotate All';
  232. {
  233. Resizes and/or rotates all currently open widows. For example,
  234. change the  ScaleAndRotate command below to
  235. ScaleAndRotate(2,2,0)  to change the size of all the images
  236. in a movie loop sequence from 128 x 128 to 256 x 256.
  237. }
  238. var
  239.   i:integer;
  240. begin
  241.   SaveState;
  242.   SetScaling('Bilinear; Create New Window');
  243.   for i:=1 to nPics do begin
  244.     ChoosePic(1);
  245.     ScaleAndRotate(1.9,1.9,0);
  246.     ChoosePic(1);
  247.     Close;
  248.   end;
  249.   for i:=1 to nPics do begin
  250.     ChoosePic(i);
  251.     SetPicName(i);
  252.   end;
  253.   RestoreState;
  254. end;
  255.  
  256.  
  257. macro 'Dispose All';
  258. begin
  259.   DisposeAll;
  260. end;
  261.  
  262. macro 'Average two Images';
  263.   {Generates the arithmetic average of two images.}
  264. begin
  265.   RequiresVersion(1.53);
  266.   if nPics<>2 then begin
  267.     PutMessage('This macro requires exactly two image windows to be open.');
  268.     Exit;
  269.   End;
  270.   ImageMath('add' ,1 ,2, 0.5, 0, 'Average');
  271.  end;
  272.  
  273.  
  274. macro 'Make Montage [M]';
  275. {Opens a new window and creates in it a composite image made from all}
  276. {currently open images. All the images must be the same size.}
  277. var
  278.   width,height,w,h,mWidth,mHeight,nWindows,left,top:integer;
  279.   RoiWidth,RoiHeight,RoiWidth,RoiHeight,i,hloc,vloc:integer;
  280.   montage,temp:integer;
  281.   scale:real;
  282.   SameSize:boolean;
  283. begin
  284.   nWindows:=nPics;
  285.   SameSize:=true;
  286.   GetPicSize(width,height);
  287.   for i:=1 to nPics do begin
  288.     SelectPic(i);
  289.     GetPicSize(w,h);
  290.     SameSize:=SameSize and (w=width) and (h=height);
  291.   end;
  292.   if (nWindows<2) or not SameSize then begin
  293.     PutMessage('This macro needs two or more images of the same size in order to create a montage.');
  294.     Exit;
  295.   end;
  296.   SetBackground(0);
  297.   MakeNewWindow('Montage');
  298.   montage:=nWindows+1;
  299.   GetPicSize(mWidth,mHeight);
  300.   SelectPic(1);
  301.   Duplicate('Temp');
  302.   temp:=nWindows+2;
  303.   scale:=GetNumber('Scaling Factor:',0.25);
  304.   hloc:=-(RoiWidth);
  305.   vloc:=0;
  306.   for i:=1 to nWindows do begin
  307.     SelectPic(i);
  308.     SelectAll;
  309.     copy;
  310.     SelectPic(temp);
  311.     paste;
  312.     SelectAll;
  313.     ScaleSelection(scale,scale);
  314.     RestoreRoi;
  315.     if i=1 then begin
  316.       GetRoi(left,top,RoiWidth,RoiHeight);
  317.       hloc:=-RoiWidth;
  318.       vloc:=0;
  319.     end;
  320.     Copy;
  321.     SelectPic(montage);
  322.     hloc:=hloc+RoiWidth;
  323.     if (hloc+RoiWidth)>mWidth then begin
  324.       hloc:=0;
  325.       vloc:=vloc+RoiHeight;
  326.     end;
  327.     MakeRoi(hloc,vloc,RoiWidth,RoiHeight);
  328.     Paste;
  329.   end;
  330.   KillRoi;
  331.   SelectPic(temp);
  332.   Dispose;
  333. end;
  334.  
  335.  
  336. macro 'Make Sine Wave';
  337. var
  338.   left,top,width,height,i:integer;
  339.   ppp,scale:real;
  340. begin
  341.   SaveState;
  342.   MakeNewWindow('Sine Wave');
  343.   SelectAll;
  344.   GetRoi(left,top,Width,Height);
  345.   if width=0 then begin
  346.     PutMessage('This macro requires a rectangular selection.');
  347.     Exit;
  348.   end;
  349.   ppp:=GetNumber('Pixels per period',100);
  350.   Scale:=ppp/6.28;
  351.   MakeRoi(left,top,1,height);
  352.   for i:=1 to width do begin
  353.     SetForeground(sin(i/scale)*127 +128);
  354.     {SetForeground((sin(i/scale)*127 +128)*(i+30)/(width));}
  355.     {SetForeground(sin(i/(ppp*((width-i+3)/width)/6.28))*127 +128);}
  356.     fill;
  357.     MoveRoi(1,0);
  358.   end;
  359.   KillRoi;
  360.   RestoreState;
  361. end;
  362.  
  363. macro 'Beep if No Selection [B]';
  364. var 
  365.   left,top,width,height:integer;
  366. begin
  367.   GetRoi(left,top,width,height);
  368.   if width=0 then beep;
  369. end;
  370.  
  371. function power(x, n: real): real;
  372. {raise x to the nth power}
  373. begin
  374.     power := exp(ln(x) * n);
  375. end;
  376.  
  377.  
  378. macro 'Exponention Demo…';
  379. var
  380.     base, ex: real;
  381. begin
  382.     base := GetNumber('Base:', 2);
  383.     ex := GetNumber('Exponent:', 5);
  384.     PutMessage(power(base, ex):6:3);
  385. end;
  386.  
  387. macro 'Convert Number to String Test…';
  388. var
  389.     n: real;
  390.     s1, s2, s3, s4: string;
  391. begin
  392.     n:=GetNumber('Enter a Number', 12.345);
  393.     s1 := concat(n);
  394.     s2 := concat(n:1:2);
  395.     s3 := concat(n:10:4);
  396.     s4 := concat(n:0);
  397.     PutMessage('s1=',s1,', s2=',s2,', s3=',s3', s4=',s4);
  398. end;
  399.  
  400.  
  401. function factorial(n: integer):integer;
  402. begin
  403.    if n > 1 then
  404.       factorial := n * factorial(n-1)
  405.    else
  406.       factorial := 1;
  407. end;
  408.  
  409.  
  410. macro 'Compute N Factorial...';
  411. var
  412.   n: integer;
  413. begin
  414.    n := GetNumber('N:', 3, 0);
  415.    PutMessage(n:1, ' factoral = ', factorial(n):1);
  416. end;
  417.  
  418.  
  419. macro '(---'; begin end;
  420.  
  421. {These macros allow you to easily switch}
  422. {transfer modes while pasting by tapping keys.}
  423. macro 'Copy Mode[1]'; begin SetOption; DoCopy; end;
  424. macro 'AND Mode[2]';  begin SetOption; DoAnd; end;
  425. macro 'OR Mode [3]';  begin SetOption; DoOr; end;
  426. macro 'XOR Mode[4]'; begin SetOption; DoXor; end;
  427. macro 'REPLACE Mode[5]';  begin SetOption; DoReplace; end;
  428. macro 'BLEND [6]';  begin SetOption; DoBlend; end;
  429. macro 'Terminate Paste [7]'; begin KillRoi end;
  430.  
  431.